Aminet 28/Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso/Aminet/dev/lang/fpc09905c.lha/fpc/inc/text.inc

Text File | 1998-09-21 | 29KB | 1,263 lines

{
    $Id: text.inc,v 1.21 1998/08/17 22:42:17 michael Exp $
    This file is part of the Free Pascal Run time library.
    Copyright (c) 1993,97 by the Free Pascal development team

    See the file COPYING.FPC, included in this distribution,
    for details about the copyright.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

 **********************************************************************}

{
  Possible Defines:

  EXTENDED_EOF    Use extended EOF checking for textfile, necessary for
                  Pipes and Sockets under Linux
  EOF_CTRLZ       Is Ctrl-Z (#26) a EOF mark for textfiles
  SHORT_LINEBREAK Use short Linebreaks #10 instead of #10#13

  Both EXTENDED_EOF and SHORT_LINEBREAK are defined in the Linux system
  unit (syslinux.pp)
}

{****************************************************************************
                    subroutines For TextFile handling
****************************************************************************}


Procedure FileCloseFunc(Var t:TextRec);
Begin
  Do_Close(t.Handle);
  t.Handle:=UnusedHandle;
End;


Procedure FileReadFunc(var t:TextRec);
Begin
  t.BufEnd:=Do_Read(t.Handle,Longint(t.Bufptr),t.BufSize);
  t.BufPos:=0;
End;


Procedure FileWriteFunc(var t:TextRec);
Begin
  Do_Write(t.Handle,Longint(t.Bufptr),t.BufPos);
  t.BufPos:=0;
End;



Procedure FileOpenFunc(var t:TextRec);
var
  Flags : Longint;
Begin
  Case t.mode Of
    fmInput : Flags:=$1000;
   fmOutput : Flags:=$1101;
   fmAppend : Flags:=$1011;
  else
   HandleError(102);
  End;
  Do_Open(t,PChar(@t.Name),Flags);
  t.CloseFunc:=@FileCloseFunc;
  t.FlushFunc:=nil;
  if t.Mode=fmInput then
   t.InOutFunc:=@FileReadFunc
  else
   begin
     t.InOutFunc:=@FileWriteFunc;
   { Only install flushing if its a NOT a file }
     if Do_Isdevice(t.Handle) then
      t.FlushFunc:=@FileWriteFunc;
   end;
End;


Procedure assign(var t:Text;const s:String);
Begin
  FillChar(t,SizEof(TextRec),0);
{ only set things that are not zero }
  TextRec(t).Handle:=UnusedHandle;
  TextRec(t).mode:=fmClosed;
  TextRec(t).BufSize:=128;
  TextRec(t).Bufptr:=@TextRec(t).Buffer;
  TextRec(t).OpenFunc:=@FileOpenFunc;
  Move(s[1],TextRec(t).Name,Length(s));
End;


Procedure assign(var t:Text;p:pchar);
begin
  Assign(t,StrPas(p));
end;


Procedure assign(var t:Text;c:char);
begin
  Assign(t,string(c));
end;


Procedure Close(var t : Text);[Public,Alias: 'CLOSE_TEXT',IOCheck];
Begin
  if InOutRes <> 0 then Exit;
  If (TextRec(t).mode<>fmClosed) Then
   Begin
   { Write pending buffer }
     If Textrec(t).Mode=fmoutput then
       FileFunc(TextRec(t).InOutFunc)(TextRec(t));
     TextRec(t).mode:=fmClosed;
   { Only close functions not connected to stdout.}
     If ((TextRec(t).Handle<>StdInputHandle) or
         (TextRec(t).Handle<>StdOutputHandle) or
         (TextRec(t).Handle<>StdErrorHandle)) Then
      FileFunc(TextRec(t).CloseFunc)(TextRec(t));
   End;
End;


Procedure OpenText(var t : Text;mode,defHdl:Longint);
Begin
  Case TextRec(t).mode Of {This gives the fastest code}
   fmInput,fmOutput,fmInOut : Close(t);
   fmClosed : ;
  else
   Begin
     InOutRes:=102;
     exit;
   End;
  End;
  TextRec(t).mode:=word(mode);
  FileFunc(TextRec(t).OpenFunc)(TextRec(t))
End;


Procedure Rewrite(var t : Text);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  OpenText(t,fmOutput,1);
End;


Procedure Reset(var t : Text);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  OpenText(t,fmInput,0);
End;


Procedure Append(var t : Text);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  OpenText(t,fmAppend,1);
End;


Procedure Flush(var t : Text);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  If TextRec(t).mode<>fmOutput Then
   exit;
{ Not the flushfunc but the inoutfunc should be used, becuase that
  writes the data, flushfunc doesn't need to be assigned }
  FileFunc(TextRec(t).InOutFunc)(TextRec(t));
End;


Procedure Erase(var t:Text);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  If TextRec(t).mode=fmClosed Then
   Do_Erase(PChar(@TextRec(t).Name));
End;


Procedure Rename(var t : text;p:pchar);[IOCheck];
Begin
  If InOutRes <> 0 then exit;
  If TextRec(t).mode=fmClosed Then
   Begin
     Do_Rename(PChar(@TextRec(t).Name),p);
     Move(p^,TextRec(t).Name,StrLen(p)+1);
   End;
End;


Procedure Rename(var t : Text;const s : string);[IOCheck];
var
  p : array[0..255] Of Char;
Begin
  If InOutRes <> 0 then exit;
  Move(s[1],p,Length(s));
  p[Length(s)]:=#0;
  Rename(t,Pchar(@p));
End;


Procedure Rename(var t : Text;c : char);[IOCheck];
var
  p : array[0..1] Of Char;
Begin
  If InOutRes <> 0 then exit;
  p[0]:=c;
  p[1]:=#0;
  Rename(t,Pchar(@p));
End;


Function Eof(Var t: Text): Boolean;[IOCheck];
Begin
  If InOutRes <> 0 then exit;
{$IFNDEF EXTENDED_EOF}
  {$IFDEF EOF_CTRLZ}
    Eof:=TextRec(t).Buffer[TextRec(t).BufPos]=#26;
    If Eof Then
     Exit;
  {$ENDIF EOL_CTRLZ}
  Eof:=(Do_FileSize(TextRec(t).Handle)<=Do_FilePos(TextRec(t).Handle));
  If Eof Then
   Eof:=TextRec(t).BufEnd <= TextRec(t).BufPos;
{$ELSE EXTENDED_EOF}
  { The previous method will NOT work on stdin and pipes or sockets.
    So how to do it ?
     1) Check if characters in buffer - Yes ? Eof=false;
     2) Read buffer full. If 0 Chars Read : Eof !
    Michael.}
  If TextRec(T).mode=fmClosed Then  { Sanity Check }
   Begin
     Eof:=True;
     Exit;
   End;
  If (TextRec(T).BufPos < TextRec(T).BufEnd) Then
   Begin
     Eof:=False;
     Exit
   End;
  TextRec(T).BufPos:=0;
  TextRec(T).BufEnd:=Do_Read(TextRec(T).Handle,Longint(TextRec(T).BufPtr),TextRec(T).BufSize);
  If TextRec(T).BufEnd<0 Then
   TextRec(T).BufEnd:=0;
  Eof:=(TextRec(T).BufEnd=0);
{$ENDIF EXTENDED_EOF}
End;


Function Eof:Boolean;
Begin
  Eof:=Eof(Input);
End;


Function SeekEof (Var F : Text) : Boolean;
Var
  TR   : ^TextRec;
  Temp : Longint;
Begin
  TR:=@TextRec(f);
  If TR^.mode<>fmInput Then exit (true);
  SeekEof:=True;
  {No data in buffer ? Fill it }
  If TR^.BufPos>=TR^.BufEnd Then
   FileFunc(TR^.InOutFunc)(TR^);

  Temp:=TR^.BufPos;
  while (TR^.BufPos<TR^.BufEnd) Do
   Begin
     If (TR^.Bufptr^[Temp] In [#9,#10,#13,' ']) Then
      Inc(Temp)
     else
      Begin
        SeekEof:=False;
        TR^.BufPos:=Temp;
        exit;
      End;
     If Temp>=TR^.BufEnd Then
      Begin
        FileFunc(TR^.InOutFunc)(TR^);
        Temp:=TR^.BufPos+1;
      End;
   End;
End;


Function SeekEof : Boolean;
Begin
  SeekEof:=SeekEof(Input);
End;


Function Eoln(var t:Text) : Boolean;
Begin
{ maybe we need new data }
  If TextRec(t).BufPos>=TextRec(t).BufEnd Then
   FileFunc(TextRec(t).InOutFunc)(TextRec(t));
  Eoln:=Eof(t) or (TextRec(t).Bufptr^[TextRec(t).BufPos] In [#10,#13]);
End;


Function Eoln : Boolean;
Begin
  Eoln:=Eoln(Input);
End;


Function SeekEoln (Var F : Text) : Boolean;
Var
  TR   : ^TextRec;
  Temp : Longint;
Begin
  TR:=@TextRec(f);
  If TR^.mode<>fmInput Then
   exit (true);
  SeekEoln:=True;
  {No data in buffer ? Fill it }
  If TR^.BufPos>=TR^.BufEnd Then
   FileFunc(TR^.InOutFunc)(TR^);
  Temp:=TR^.BufPos;
  while (TR^.BufPos<TR^.BufEnd) Do
   Begin
     Case (TR^.Bufptr^[Temp]) Of
      #10 : Exit;
   #9,' ' : Inc(Temp)
     else
      Begin
        SeekEoln:=False;
        TR^.BufPos:=Temp;
        exit;
      End;
     End;
     If Temp>=TR^.BufEnd Then
      Begin
        FileFunc(TR^.InOutFunc)(TR^);
        Temp:=TR^.BufPos+1;
      End;
   End;
End;


Function SeekEoln : Boolean;
Begin
  SeekEoln:=SeekEoln(Input);
End;


Procedure SetTextBuf(Var F : Text; Var Buf);[INTERNPROC: In_settextbuf_file_x];


Procedure SetTextBuf(Var F : Text; Var Buf; Size : Word);
Begin
  TextRec(f).BufPtr:=@Buf;
  TextRec(f).BufSize:=Size;
  TextRec(f).BufPos:=0;
  TextRec(f).BufEnd:=0;
End;


{*****************************************************************************
                               Write(Ln)
*****************************************************************************}

Procedure WriteBuffer(var f:TextRec;var b;len:longint);
var
  p   : pchar;
  left,
  idx : longint;
begin
  p:=pchar(@b);
  idx:=0;
  left:=f.BufSize-f.BufPos;
  while len>left do
   begin